home *** CD-ROM | disk | FTP | other *** search
- ;;; w3-style.el,v --- Emacs-W3 binding style sheet mechanism
- ;; Author: wmperry
- ;; Created: 1995/08/27 01:10:25
- ;; Version: 1.37
- ;; Keywords: faces, hypermedia
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
- ;;;
- ;;; This file is not part of GNU Emacs, but the same permissions apply.
- ;;;
- ;;; GNU Emacs is free software; you can redistribute it and/or modify
- ;;; it under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 2, or (at your option)
- ;;; any later version.
- ;;;
- ;;; GNU Emacs is distributed in the hope that it will be useful,
- ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Emacs; see the file COPYING. If not, write to
- ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; A style sheet mechanism for emacs-w3
- ;;;
- ;;; This will eventually be able to under DSSSL[-lite] as well as the
- ;;; experimental W3C mechanism
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (defun w3-blend-colors (start end percentage)
- (interactive "sStart Color:
- sEnd Color:
- nPercentage: ")
- (setq percentage (max 0 (min percentage 100)))
- (let* ((vals (w3-color-rgb-components start))
- (red-1 (nth 0 vals))
- (green-1 (nth 1 vals))
- (blue-1 (nth 2 vals))
- (new (w3-color-rgb-components end))
- (red-2 (abs (/ (* percentage (- red-1 (nth 0 new))) 100)))
- (green-2 (abs (/ (* percentage (- green-1 (nth 1 new))) 100)))
- (blue-2 (abs (/ (* percentage (- blue-1 (nth 2 new))) 100))))
- (format "#%04x%04x%04x"
- (abs (- red-1 red-2))
- (abs (- green-1 green-2))
- (abs (- blue-1 blue-2)))))
-
- (defun w3-percentage-from-date (date-1 date-2 length)
- "Return the percentage of LENGTH that has elapsed between DATE-1 and DATE-2
- DATE-1 and DATE-2 are lists as returned by `current-time'
- LENGTH is in days"
- (let ((secsbetween (+ (lsh (abs (- (nth 0 date-1) (nth 0 date-2))) 16)
- (abs (- (nth 1 date-1) (nth 1 date-2)))))
- (lengthinsecs (* length 24 60 60)))
- (round (* (/ (float secsbetween) (max lengthinsecs 1)) 100))))
-
- (defun w3-parse-dssl-lite (fname &optional string)
- (let ((dest-buf (current-buffer))
- (url-mime-accept-string
- "Accept: application/stylesheet ; notation=dsssl-lite")
- (sheet nil))
- (save-excursion
- (set-buffer (get-buffer-create
- (url-generate-new-buffer-name " *style*")))
- (erase-buffer)
- (if fname (url-insert-file-contents fname))
- (goto-char (point-max))
- (if string (insert string))
- (goto-char (point-min))
- (delete-matching-lines "^[ \t]*#") ; Nuke comments
- (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
- (goto-char (point-min))
- (insert "(")
- (goto-char (point-max))
- (insert ")")
- (goto-char (point-min))
- (setq sheet (condition-case ()
- (read (current-buffer))
- (error nil)))
- ;; Now need to convert the DSSSL-lite flow objects
- ;; into our internal representation
- ;; WORK WORK WORK!
- )))
-
- (if (not (fboundp 'string-to-number))
- (fset 'string-to-number 'string-to-int))
-
- (defun w3-spatial-to-canonical (spec)
- "Convert SPEC (in inches, millimeters, points, or picas) into pixels"
- (let ((num nil)
- (type nil)
- (dim1 (+ 25 (/ (float 4) 10)))
- (dim2 (float 72))
- (retval nil))
- (if (string-match "[^0-9.]+$" spec)
- (setq type (substring spec (match-beginning 0))
- spec (substring spec 0 (match-beginning 0)))
- (setq type "px"
- spec spec))
- (setq num (string-to-number spec))
- (cond
- ((member type '("pixel" "px" "pix"))
- (setq retval num
- num nil))
- ((member type '("point" "pt"))
- (setq num num))
- ((member type '("inch" "in"))
- (setq num (/ num dim2)))
- ((string= type "mm")
- (setq num (* num (/ dim1 dim2))))
- ((string= type "cm")
- (setq num (* num (/ dim1 dim2))))
- )
- (if (not retval)
- (setq retval (* 10 num)))
- retval))
-
- (defun w3-lookup-rgb-components (color)
- "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
- The list (R G B) is returned, or an error is signaled if the lookup fails."
- (let ((lib-list (if (boundp 'x-library-search-path)
- x-library-search-path
- ;; This default is from XEmacs 19.13 - hope it covers
- ;; everyone.
- (list "/usr/X11R6/lib/X11/"
- "/usr/X11R5/lib/X11/"
- "/usr/lib/X11R6/X11/"
- "/usr/lib/X11R5/X11/"
- "/usr/local/X11R6/lib/X11/"
- "/usr/local/X11R5/lib/X11/"
- "/usr/local/lib/X11R6/X11/"
- "/usr/local/lib/X11R5/X11/"
- "/usr/X11/lib/X11/"
- "/usr/lib/X11/"
- "/usr/local/lib/X11/"
- "/usr/X386/lib/X11/"
- "/usr/x386/lib/X11/"
- "/usr/XFree86/lib/X11/"
- "/usr/unsupported/lib/X11/"
- "/usr/athena/lib/X11/"
- "/usr/local/x11r5/lib/X11/"
- "/usr/lpp/Xamples/lib/X11/"
- "/usr/openwin/lib/X11/"
- "/usr/openwin/share/lib/X11/")))
- file r g b)
- (while lib-list
- (setq file (expand-file-name "rgb.txt" (car lib-list)))
- (if (file-readable-p file)
- (setq lib-list nil)
- (setq lib-list (cdr lib-list)
- file nil)))
- (if (null file)
- (error "w3-lookup-rgb-components: Can't find rgb.txt file.")
- (save-excursion
- (set-buffer (find-file-noselect file))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
- (progn
- (beginning-of-line)
- (setq r (* (read (current-buffer)) 256)
- g (* (read (current-buffer)) 256)
- b (* (read (current-buffer)) 256)))
- (message "No such color: %s" color)
- (w3-warn 'html (format "No such color: %s" color))
- (setq r 0
- g 0
- b 0))
- (list r g b) ))))))
-
- (defun w3-hex-string-to-number (string)
- "Convert STRING to an integer by parsing it as a hexadecimal number."
- (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
- (?1 . 1) (?b . 11) (?B . 11)
- (?2 . 2) (?c . 12) (?C . 12)
- (?3 . 3) (?d . 13) (?D . 13)
- (?4 . 4) (?e . 14) (?E . 14)
- (?5 . 5) (?f . 15) (?F . 15)
- (?6 . 6)
- (?7 . 7)
- (?8 . 8)
- (?9 . 9)))
- (n 0)
- (i 0)
- (lim (length string)))
- (while (< i lim)
- (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
- i (1+ i)))
- n ))
-
- (defun w3-parse-rgb-components (color)
- "Parse RGB color specification and return a list of integers (R G B).
- #FEFEFE and rgb:fe/fe/fe style specifications are parsed."
- (let ((case-fold-search t)
- r g b str)
- (cond ((string-match "^#[0-9a-f]+$" color)
- (cond
- ((= (length color) 4)
- (setq r (w3-hex-string-to-number (substring color 1 2))
- g (w3-hex-string-to-number (substring color 2 3))
- b (w3-hex-string-to-number (substring color 3 4))
- r (* r 4096)
- g (* g 4096)
- b (* b 4096)))
- ((= (length color) 7)
- (setq r (w3-hex-string-to-number (substring color 1 3))
- g (w3-hex-string-to-number (substring color 3 5))
- b (w3-hex-string-to-number (substring color 5 7))
- r (* r 256)
- g (* g 256)
- b (* b 256)))
- ((= (length color) 10)
- (setq r (w3-hex-string-to-number (substring color 1 4))
- g (w3-hex-string-to-number (substring color 4 7))
- b (w3-hex-string-to-number (substring color 7 10))
- r (* r 16)
- g (* g 16)
- b (* b 16)))
- ((= (length color) 13)
- (setq r (w3-hex-string-to-number (substring color 1 5))
- g (w3-hex-string-to-number (substring color 5 9))
- b (w3-hex-string-to-number (substring color 9 13))))
- (t (error "Invalid RGB color specification: %s" color))))
- ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
- color)
- (if (or (> (- (match-end 1) (match-beginning 1)) 4)
- (> (- (match-end 2) (match-beginning 2)) 4)
- (> (- (match-end 3) (match-beginning 3)) 4))
- (error "Invalid RGB color specification: %s" color)
- (setq str (match-string 1 color)
- r (* (w3-hex-string-to-number str)
- (expt 16 (- 4 (length str))))
- str (match-string 2 color)
- g (* (w3-hex-string-to-number str)
- (expt 16 (- 4 (length str))))
- str (match-string 3 color)
- b (* (w3-hex-string-to-number str)
- (expt 16 (- 4 (length str)))))))
- (t
- (w3-warn 'html (format "Invalid RGB color specification: %s"
- color))
- (setq r 0
- g 0
- b 0)))
- (list r g b) ))
-
- (defun w3-color-rgb-components (color)
- "Return the RGB components of COLOR as a list of integers (R G B).
- 16-bit values are always returned.
- #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
- into their components.
- RGB values for color names are looked up in the rgb.txt file.
- The variable x-library-search-path is use to locate the rgb.txt file."
- (let ((case-fold-search t))
- (cond
- ((or (string-match "^#" color)
- (string-match "^rgb:" color))
- (w3-parse-rgb-components color))
- ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
- color)
- (let ((r (string-to-number (url-match color 1)))
- (g (string-to-number (url-match color 2)))
- (b (string-to-number (url-match color 3))))
- (if (floatp r)
- (setq r (round (* 255 r))
- g (round (* 255 g))
- b (round (* 255 b))))
- (w3-parse-rgb-components (format "#%02x%02x%02x" r g b))))
- (t
- (w3-lookup-rgb-components color)))))
-
- (defun w3-normalize-color (color)
- "Return an RGB tuple, given any form of input. If an error occurs, black
- is returned."
- (apply 'format "#%04x%04x%04x" (w3-color-rgb-components color)))
-
-
- (defun w3-parse-arena-style-sheet (fname &optional string)
- (let ((dest-buf (current-buffer))
- (url-mime-accept-string
- (concat
- "Accept: application/stylesheet ; notation=experimental\r\n"
- "Accept: application/stylesheet ; notation=w3c-style"))
- (save-pos nil)
- (applies-to nil) ; List of tags to apply style to
- (attrs nil) ; List of name/value pairs
- (tag nil)
- (att nil)
- (val nil)
- (sheet nil))
- (save-excursion
- (set-buffer (get-buffer-create
- (url-generate-new-buffer-name " *style*")))
- (erase-buffer)
- (if fname (url-insert-file-contents fname))
- (goto-char (point-max))
- (if string (insert string))
- (goto-char (point-min))
- (delete-matching-lines "^[ \t]*#") ; Nuke comments
- (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
- (w3-replace-regexp "--.*$" "") ; Nuke new style comments
- (w3-replace-regexp "^[ \t\r]+" "") ; Nuke whitespace at beg. of line
- (w3-replace-regexp "[ \t\r]+$" "") ; Nuke whitespace at end of line
- (w3-replace-regexp "![ \t]*\\([^ \t\r\n]+\\).*" "; priority=\"\\1\"")
- (goto-char (point-min))
- (while (not (eobp))
- (beginning-of-line)
- (setq save-pos (point))
- (skip-chars-forward "^:")
- (downcase-region save-pos (point))
- ;; Could use read(), but it would slurp in the ':' as well
- (setq applies-to (url-split (buffer-substring save-pos (point))
- "[ \t\r\n,&]"))
- (skip-chars-forward " \t:")
- (setq save-pos (point))
- (end-of-line)
- (skip-chars-backward "\r")
- (setq attrs (mm-parse-args save-pos (point) t))
- (skip-chars-forward "\r\n")
- (while applies-to
- (setq tag (intern (downcase (car (car applies-to))))
- applies-to (cdr applies-to))
- (let ((loop attrs))
- (while loop
- (setq att (car (car loop))
- val (cdr (car loop))
- loop (cdr loop))
- (cond
- ((string= "align" att)
- (setq val (intern val)))
- ((or (string= "indent" att)
- (string-match "^margin" att))
- (setq val (string-to-int val)))
- (t nil))
- (let* ((node-1 (assoc tag sheet))
- (node-2 (and node-1 (assoc att node-1)))
- (node-3 (assoc (symbol-name tag) sheet))
- (node-4 (and node-3 (assoc att node-3))))
- (cond
- ((not node-3)
- (setq sheet (cons (cons (symbol-name tag)
- (list (cons att val))) sheet)))
- ((not node-4)
- (setcdr node-3 (cons (cons att val) (cdr node-3))))
- (t
- (setcdr node-4 val)))
- (cond
- ((not node-1)
- (setq sheet (cons (cons tag (list (cons att val))) sheet)))
- ((not node-2)
- (setcdr node-1 (cons (cons att val) (cdr node-1))))
- (t
- (setcdr node-2 val))))))))
- (set-buffer-modified-p nil)
- (kill-buffer (current-buffer)))
- sheet))
-
- (if (and (not (fboundp 'find-face))
- (fboundp 'face-list))
- (defun find-face (face)
- (car-safe (memq face (face-list)))))
-
- (defun w3-create-x-font (family style size em)
- (format
- "-*-%s-%s-%s-*-*-*-%s-%s-*-*-*-iso8859-1"
- family
- (if (string-match "bold" style) "bold" "medium")
- (if (string-match "italic" style) "i" "r")
- (if (eq em 'pixels) size "*")
- (if (eq em 'points) size "*")))
-
- (defun w3-generate-stylesheet-faces (sheet)
- (url-lazy-message "Applying style hints...")
- (let ((todo (delq nil (mapcar
- (function (lambda (x) (if (symbolp (car x)) x)))
- sheet)))
- (cur nil)
- (node nil)
- (fore nil)
- (back nil)
- (font nil)
- (family nil)
- (scale nil)
- (var nil)
- (locale (if (fboundp 'valid-specifier-locale-p) (current-buffer)))
- (face-name nil))
- (while todo
- (setq cur (car todo)
- todo (cdr todo)
- var (cdr-safe (assoc (car cur) w3-all-faces))
- node cur)
- (if node
- (progn
- (setq fore (downcase (or (cdr-safe (assoc "color.text" node))
- (cdr-safe (assoc "text-color" node))
- (cdr-safe (assoc "font.color" node))
- (cdr-safe (assoc "font-color" node))
- "none"))
- back (downcase (or (cdr-safe (assoc "color.background" node))
- (cdr-safe (assoc "text-background" node))
- (cdr-safe (assoc "font-background" node))
- (cdr-safe (assoc "font.background" node))
- "none"))
- scale (or (cdr-safe (assoc "font.size" node))
- (cdr-safe (assoc "font-size" node)))
- scale (cond
- ((null scale) "none")
- ((listp scale) (condition-case ()
- (int-to-string
- (eval (read
- (format "(%c 3 %s)"
- (car scale)
- (cdr scale)))))
- (error 3)))
- ((stringp scale) (downcase scale)))
- family (downcase (or (cdr-safe (assoc "font.family" node))
- (cdr-safe (assoc "font-family" node))
- "none"))
- font (downcase (or (cdr-safe (assoc "font.style" node))
- (cdr-safe (assoc "font-style" node))
- "none"))
- font (mapconcat (function (lambda (x)
- (cond
- ((= x ? ) "")
- ((= x ?,) "-")
- ((= x ?&) "-")
- (t (char-to-string x)))))
- font "")
- font (mapconcat 'identity
- (sort (mapcar 'car (url-split font "-"))
- 'string-lessp)
- "-")
- face-name (intern (if (fboundp 'make-face-larger)
- (concat fore "/" back "/" font
- "/" scale)
- (concat fore "/" back "/" font))))
- (cond
- ((and (string= fore "none")
- (string= back "none")
- (string= scale "none")
- (string= font "none"))
- nil) ; Do nothing - no style directives
- ((find-face face-name)
- (setcdr node (cons (cons "face" face-name) (cdr node)))
- (let ((x (assoc (symbol-name (car node)) w3-current-stylesheet)))
- (if x
- (setcdr x (cons (cons "face" face-name) (cdr x)))))
- (and var (set var face-name))) ; face already created
- (t
- (setcdr node (cons (cons "face" face-name) (cdr node)))
- (let ((x (assoc (symbol-name (car node)) w3-current-stylesheet)))
- (if x
- (setcdr x (cons (cons "face" face-name) (cdr x)))))
- (make-face face-name)
- (and var (set var face-name))
- (if (not (string= fore "none"))
- (w3-munge-color-fore face-name (w3-normalize-color fore)))
- (if (not (string= back "none"))
- (w3-munge-color-back face-name (w3-normalize-color back)))
- (if (and (not (string= scale "none"))
- (fboundp 'make-face-larger))
- (let ((size (1- (string-to-int scale))))
- (mapcar (cond
- ((= size 0) 'identity)
- ((< size 0) 'make-face-smaller)
- ((> size 0) 'make-face-larger))
- (make-list (abs size) face-name))))
- (if (string= font "none")
- nil
- (progn
- (if (string-match "bold" font)
- (condition-case ()
- (make-face-bold face-name)
- (error nil)))
- (if (string-match "italic" font)
- (condition-case ()
- (make-face-italic face-name)
- (error nil)))
- (if (string-match "underline" font)
- (apply 'set-face-underline-p face-name t))))))))))
- (url-lazy-message "Applying style hints... done"))
-
- (defun w3-handle-style (&optional args)
- (let ((fname (or (cdr-safe (assoc "href" args))
- (cdr-safe (assoc "src" args))
- (cdr-safe (assoc "uri" args))))
- (type (downcase (or (cdr-safe (assoc "notation" args))
- "experimental")))
- (url-working-buffer " *style*")
- (base (cdr-safe (assoc "base" args)))
- (stylesheet nil)
- (string (cdr-safe (assoc "data" args))))
- (if fname (setq fname (url-expand-file-name fname
- (cdr-safe
- (assoc base w3-base-alist)))))
- (save-excursion
- (set-buffer (get-buffer-create url-working-buffer))
- (erase-buffer)
- (setq url-be-asynchronous nil)
- (cond
- ((member type '("experimental" "arena" "w3c-style"))
- (setq stylesheet (w3-parse-arena-style-sheet fname string)))
- ((string= type "dsssl-lite")
- (setq stylesheet (w3-parse-dsssl-lite fname string)))
- (t
- (w3-warn 'html "Unknown stylesheet notation: %s" type))))
- (setq w3-current-stylesheet stylesheet)
- (if (and w3-current-stylesheet (fboundp 'make-face))
- (w3-generate-stylesheet-faces w3-current-stylesheet))))
-
- (provide 'w3-style)
-